home *** CD-ROM | disk | FTP | other *** search
/ PD ROM 1 / PD ROM Volume I - Macintosh Software from BMUG (1988).iso / Programming / Programming Tools / FORTRAN Routines / SAFE2SUB.FOR < prev    next >
Encoding:
Text File  |  1986-07-17  |  37.7 KB  |  1,086 lines  |  [TEXT/ttxt]
  1. $LINESIZE: 132
  2. $PAGESIZE: 61
  3. $STORAGE: 2
  4. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  5. C                                                                      C
  6. C                          M I C R O S A F E                           C
  7. C                Structural Analysis by Finite Elements                C
  8. C                     Module : SAFESOLV,  2nd Part                     C
  9. C                            Version : 2-D                             C
  10. C                                                                      C
  11. C         COPYRIGHT (C) by MICROSTRESS Corporation - 1985,1986         C
  12. C                         ALL RIGHTS RESERVED                          C
  13. C                                                                      C
  14. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  15.       SUBROUTINE parsfn (flspec,ddrive,fldriv,driven,flpath,flname,
  16.      +                   flextn)
  17. C
  18. C  Parse a file specification and get drive, path, name and extension
  19. C
  20.       IMPLICIT INTEGER (a-z)
  21.       CHARACTER fldriv*6,flpath*64,flname*9,flextn*5,flspec*78,colon*2,
  22.      +          bslash*2,period*2
  23. C
  24. C  Initialization.
  25. C
  26.       call setstr (78,flspec)
  27.       call pakstr (flspec)
  28.       call upcstr (flspec)
  29.       fldriv='      '
  30.       call setstr (6,fldriv)
  31.       flpath='
  32.      +         '
  33.       call setstr (64,flpath)
  34.       flname='         '
  35.       call setstr (9,flname)
  36.       flextn='     '
  37.       call setstr (5,flextn)
  38.       colon=': '
  39.       call setstr (2,colon)
  40.       bslash='\ '
  41.       call setstr (2,bslash)
  42.       period='. '
  43.       call setstr (2,period)
  44. C
  45. C  Determine the drive specification
  46. C
  47.       locatn=locstr (1,flspec,colon)
  48.       if (locatn .eq. 0) then
  49.           driven=ddrive+1
  50.       else
  51.           call movstr (fldriv,1,1,flspec,1,locatn)
  52.           driven=ascstr (locatn-1,flspec)-64
  53.       endif
  54. C
  55. C  Determine the path specification
  56. C
  57.       firstc=locatn+1
  58.       lastoc=locatn
  59.    10 locatn=locstr (lastoc+1,flspec,bslash)
  60.       if (locatn .ne. 0) then
  61.           lastoc=locatn
  62.           goto 10
  63.       else
  64.           call movstr (flpath,1,1,flspec,firstc,lastoc-firstc+1)
  65.       endif
  66. C
  67. C  Determine the extension specification
  68. C
  69.       length=lenstr(flspec)
  70.       locatn=locstr (lastoc+1,flspec,period)
  71.       if (locatn .ne. 0) then
  72.           call movstr (flextn,1,1,flspec,locatn,length-locatn+1)
  73.       else
  74.           locatn=length+1
  75.       endif
  76. C
  77. C  Determine the name specification
  78. C
  79.       call movstr (flname,1,1,flspec,lastoc+1,locatn-lastoc-1)
  80. C
  81. C  Pack the return strings
  82. C
  83.       call pakstr (fldriv)
  84.       call pakstr (flpath)
  85.       call pakstr (flname)
  86.       call pakstr (flextn)
  87.       RETURN
  88.       END
  89. $PAGE
  90.       SUBROUTINE triasemb (i,j,k,th,eyoung,pratio)
  91. C
  92. C  Assemble stiffness matrix for triangular plate
  93. C
  94.       DOUBLE PRECISION th,diffnc(2,4),ftcons(9),eyoung,pratio
  95.       common /coordi/ coonod(2,401)
  96.       diffnc(1,2)=coonod(1,J)-coonod(1,I)
  97.       diffnc(2,2)=coonod(2,J)-coonod(2,I)
  98.       diffnc(1,3)=coonod(1,K)-coonod(1,J)
  99.       diffnc(2,3)=coonod(2,K)-coonod(2,J)
  100.       diffnc(1,1)=coonod(1,I)-coonod(1,K)
  101.       diffnc(2,1)=coonod(2,I)-coonod(2,K)
  102.       ftcons(6)=diffnc(2,3)*diffnc(1,2)-diffnc(1,3)*diffnc(2,2)
  103.       ftcons(1)=eyoung*TH/(4*ftcons(6))
  104.       ftcons(8)=ftcons(1)/(1-pratio)
  105.       ftcons(7)=ftcons(1)/(1+pratio)
  106.       ftcons(1)=ftcons(7)*
  107.      +          (diffnc(1,3)*diffnc(1,3)+diffnc(2,3)*diffnc(2,3))
  108.       ftcons(2)=ftcons(7)*
  109.      +          (diffnc(1,1)*diffnc(1,1)+diffnc(2,1)*diffnc(2,1))
  110.       ftcons(3)=ftcons(7)*
  111.      +          (diffnc(1,3)*diffnc(1,2)+diffnc(2,3)*diffnc(2,2))
  112.       ftcons(4)=ftcons(7)*ftcons(6)
  113.       ftcons(5)=ftcons(7)*
  114.      +          (diffnc(1,2)*diffnc(1,2)+diffnc(2,2)*diffnc(2,2))
  115.       I1=3*I-2
  116.       J1=3*J-2
  117.       K1=3*K-2
  118.       CALL assemble (i1,i1,ftcons(1)+ftcons(8)*diffnc(2,3)*diffnc(2,3),
  119.      +               -ftcons(8)*diffnc(1,3)*diffnc(2,3),0.)
  120.       CALL assemble (i1,j1,-ftcons(1)-ftcons(3)+
  121.      +               ftcons(8)*diffnc(2,3)*diffnc(2,1),
  122.      +               -ftcons(4)-ftcons(8)*diffnc(2,3)*diffnc(1,1),0.)
  123.       CALL assemble (i1,k1,ftcons(3)+ftcons(8)*diffnc(2,2)*diffnc(2,3),
  124.      +               ftcons(4)-ftcons(8)*diffnc(2,3)*diffnc(1,2),0.)
  125.       CALL assemble (i1+1,i1+1,ftcons(1)+
  126.      +               ftcons(8)*diffnc(1,3)*diffnc(1,3),0.,0.)
  127.       CALL assemble (i1+1,J1,ftcons(4)-ftcons(8)*
  128.      +               diffnc(2,1)*diffnc(1,3),-ftcons(1)-ftcons(3)+
  129.      +               ftcons(8)*diffnc(1,1)*diffnc(1,3),0.)
  130.       CALL assemble (i1+1,K1,
  131.      +               -ftcons(4)-ftcons(8)*diffnc(2,2)*diffnc(1,3),
  132.      +               ftcons(3)+ftcons(8)*diffnc(1,2)*diffnc(1,3),0.)
  133.       CALL assemble (J1,j1,ftcons(2)+ftcons(8)*diffnc(2,1)*diffnc(2,1),
  134.      +               -ftcons(8)*diffnc(2,1)*diffnc(1,1),0.)
  135.       CALL assemble (j1,K1,-ftcons(3)-ftcons(5)+
  136.      +               ftcons(8)*diffnc(2,1)*diffnc(2,2),
  137.      +               -ftcons(4)-ftcons(8)*diffnc(2,1)*diffnc(1,2),0.)
  138.       CALL assemble (j1+1,j1+1,
  139.      +               ftcons(2)+ftcons(8)*diffnc(1,1)*diffnc(1,1),0.,0.)
  140.       CALL assemble (j1+1,k1,ftcons(4)-
  141.      +               ftcons(8)*diffnc(1,1)*diffnc(2,2),-ftcons(3)-
  142.      +               ftcons(5)+ftcons(8)*diffnc(1,1)*diffnc(1,2),0.)
  143.       CALL assemble (K1,K1,ftcons(5)+ftcons(8)*diffnc(2,2)*diffnc(2,2),
  144.      +               -ftcons(8)*diffnc(1,2)*diffnc(2,2),0.)
  145.       CALL assemble (k1+1,k1+1,
  146.      +               ftcons(5)+ftcons(8)*diffnc(1,2)*diffnc(1,2),0.,0.)
  147.       RETURN
  148.       END
  149. $PAGE
  150.       SUBROUTINE assemble (irow,icol,add1,add2,add3)
  151. C
  152. C  Assemble the stiffness matrix
  153. C
  154.       DOUBLE PRECISION stmtrx,stmqcn,add(3),add1,add2,add3
  155.       INTEGER longi*4
  156.       COMMON /global/ numdof,stmqcn(2,2)
  157.       common /sizebw/ malhbw
  158.       COMMON /aaaaaa/ stmtrx(8200)
  159.       add(1)=add1
  160.       add(2)=add2
  161.       add(3)=add3
  162.       do 10 i=1,3
  163.       if (add(i) .ne. 0.) then
  164.           ic=icol+i-1
  165.           if ((irow .le. numdof) .and. (ic .le. numdof)) then
  166.               longi=ic+irow-1-malhbw
  167.               if (irow .ge. ic) then
  168.                   longi=longi+malhbw*ic
  169.               else
  170.                   longi=longi+malhbw*irow
  171.               endif
  172.               stmtrx(longi)=stmtrx(longi)+add(i)
  173.           else
  174.               longi=ic+irow-2-numdof
  175.               if (irow .gt. numdof) then
  176.                   if (ic .le. numdof) then
  177.                       longi=longi+ic*(malhbw+1)
  178.                       stmtrx(longi)=stmtrx(longi)+add(i)
  179.                   else
  180.                       ir=irow-numdof
  181.                       icband=ic-numdof
  182.                       stmqcn(ir,icband)=stmqcn(ir,icband)+add(i)
  183.                       stmqcn(icband,ir)=stmqcn(ir,icband)
  184.                   endif
  185.               else
  186.                   longi=longi+irow*(malhbw+1)
  187.                   stmtrx(longi)=stmtrx(longi)+add(i)
  188.               endif
  189.           endif
  190.       ENDIF
  191.    10 continue
  192.       RETURN
  193.       END
  194. $PAGE
  195.       SUBROUTINE triloads (inp1,inp2,inp3,th,eyoung,pratio,lpl,nodepl)
  196. C
  197. C  Calculate forces and stresses in triangular plate
  198. C
  199.       DOUBLE PRECISION disdof,corfor,eyoung,pratio,th,
  200.      +                 diffnc(2,4),ftcons(9)
  201.       DIMENSION inp(3),corfor(2,3),nodepl(4,500)
  202.       INTEGER previd
  203.       common /coordi/ coonod(2,401)
  204.       COMMON /plates/ disdof(1203),pltecf(2,4),plstrs(3,500),
  205.      +                  reafor(3,400),pstnor(3,400),pstacc(3,400)
  206.       previd(k,l)=MOD(k+l-2,l)+1
  207.       nextid(k,l)=MOD(k,l)+1
  208.       inp(1)=inp1
  209.       inp(2)=inp2
  210.       inp(3)=inp3
  211.       I=nodepl(inp(1),LPL)
  212.       J=nodepl(inp(2),LPL)
  213.       IF (inp(3) .lt. 0) THEN
  214.           K=-inp(3)
  215.           nan=2
  216.       ELSE
  217.           K=nodepl(inp(3),LPL)
  218.           nan=3
  219.       ENDIF
  220.       I1=3*I-2
  221.       J1=3*J-2
  222.       K1=3*K-2
  223.       diffnc(1,2)=coonod(1,J)-coonod(1,I)
  224.       diffnc(2,2)=coonod(2,J)-coonod(2,I)
  225.       diffnc(1,3)=coonod(1,K)-coonod(1,J)
  226.       diffnc(2,3)=coonod(2,K)-coonod(2,J)
  227.       diffnc(1,1)=coonod(1,I)-coonod(1,K)
  228.       diffnc(2,1)=coonod(2,I)-coonod(2,K)
  229.       ftcons(4)=eyoung/((1+pratio)*(diffnc(1,1)*diffnc(2,2)-
  230.      +          diffnc(1,2)*diffnc(2,1)))
  231.       ftcons(5)=diffnc(2,3)*disdof(I1)+diffnc(2,1)*disdof(J1)+
  232.      +          diffnc(2,2)*disdof(K1)
  233.       ftcons(6)=diffnc(1,3)*disdof(I1+1)+diffnc(1,1)*disdof(J1+1)+
  234.      +          diffnc(1,2)*disdof(K1+1)
  235.       ftcons(1)=(pratio*ftcons(6)-ftcons(5))*ftcons(4)/(1-pratio)
  236.       ftcons(2)=(ftcons(6)-pratio*ftcons(5))*ftcons(4)/(1-pratio)
  237.       ftcons(3)=(diffnc(1,3)*disdof(I1)-diffnc(2,3)*disdof(I1+1)+
  238.      +        diffnc(1,1)*disdof(J1)-diffnc(2,1)*disdof(J1+1)+
  239.      +        diffnc(1,2)*disdof(K1)-diffnc(2,2)*disdof(K1+1))*
  240.      +        ftcons(4)/2
  241.       DO 20 LL=1,NAN
  242.       INDX=nodepl(inp(LL),LPL)
  243.       ftcons(7)=ABS(diffnc(2,nextid(LL,3))-diffnc(2,LL))/
  244.      +          (ABS(diffnc(1,nextid(LL,3))-diffnc(1,LL))+
  245.      +          ABS(diffnc(2,nextid(LL,3))-diffnc(2,LL)))
  246.       DO 10 L=1,2
  247.       corfor(L,LL)=TH*.5*(diffnc(1,previd(LL,3))*ftcons(4-L)-
  248.      +    diffnc(2,previd(LL,3))*ftcons(2*L-1))
  249.       pltecf(L,inp(LL))=pltecf(L,inp(LL))+corfor(L,LL)
  250.       ftcons(7)=1-ftcons(7)
  251.       reafor(L,INDX)=reafor(L,INDX)+corfor(L,LL)
  252.       pstnor(L,INDX)=pstnor(L,INDX)+ftcons(7)
  253.       pstacc(L,INDX)=pstacc(L,INDX)+ftcons(7)*ftcons(L)
  254.    10 CONTINUE
  255.       pstacc(3,INDX)=pstacc(3,INDX)+ftcons(3)
  256.       pstnor(3,INDX)=pstnor(3,INDX)+1
  257.       plstrs(LL,LPL)=plstrs(LL,LPL)+ftcons(LL)
  258.    20 CONTINUE
  259.       IF (nan .EQ. 2) plstrs(3,LPL)=plstrs(3,LPL)+ftcons(3)
  260.       RETURN
  261.       END
  262. $PAGE
  263.       SUBROUTINE opnfil (ierror)
  264. C
  265. C  Open a file for output with verification
  266. C
  267.       LOGICAL ffound
  268.       CHARACTER inpfil*78,outfil*78,prompt*55,intgst*25
  269.       common /filenm/ inpfil,outfil
  270.       inquire (FILE=outfil,EXIST=ffound)
  271.       if (.not.(ffound)) then
  272.           call setstr (78,outfil)
  273.           call pakstr (outfil)
  274.           length=lenstr(outfil)+1
  275.           call expstr (outfil)
  276.           call resstr (outfil)
  277.           call setstr (length,outfil)
  278.           call chopwr (outfil,ierror)
  279.           if (ierror .ne. 0) then
  280.               call resstr (outfil)
  281.               length=length-1
  282.               call wrfstr (float(length),intgst)
  283.               length=lenstr (intgst)
  284.               prompt='('' ERROR : File "'',a  ,''" cannot be open. Try a
  285.      +gain.'') '
  286.               call setstr (55,prompt)
  287.               call movstr (prompt,21,0,intgst,1,length)
  288.               call resstr (prompt)
  289.               write (*,prompt) outfil
  290.               return
  291.           endif
  292.           call resstr (outfil)
  293.       endif
  294.       OPEN (2,FILE=outfil,STATUS='new')
  295.       ierror=0
  296.       return
  297.       END
  298. $PAGE
  299.       SUBROUTINE diskroom (nbytes)
  300. C
  301. C  Update count of characters in output file to avoid disk full errors.
  302. C
  303.       INTEGER frespc*4,odrive,scrflg,asciic
  304.       COMMON /dskrom/ scrflg,odrive
  305. C
  306.       if (nbytes .eq. 0) then
  307.           call dskspc (odrive,frespc)
  308.           frespc=frespc-1
  309.       else
  310. C
  311.    20     frespc=frespc-nbytes
  312. C
  313.           if (frespc .lt. 0) then
  314.               close (2)
  315.               asciic=odrive+64
  316.               write (*,30)
  317.    30         format (//' ERROR : Output file disk is full.')
  318.    32         write (*,35) char(asciic)
  319.    35         format (' Change the disk in drive ',a1,
  320.      +                ' and press any key to continue.')
  321.               call confrm
  322.               if (scrflg .eq. 0) write (*,40)
  323.    40         format (1x\)
  324.               call opnfil (ierror)
  325.               if (ierror .ne. 0) goto 32
  326.               call dskspc (odrive,frespc)
  327.               frespc=frespc-1
  328.               goto 20
  329.           endif
  330.       endif
  331.       return
  332.       end
  333. $PAGE
  334.       SUBROUTINE verify (idline,entry,ierror,maxban,youngm)
  335. C
  336. C  Verify input data
  337. C
  338.       implicit integer (a-z)
  339.       real coonod,entry,boulow,bouhig,ftcons,fltstr,youngm
  340.       CHARACTER buffer*126,slash*2,space*2,stcons*25,line*79,inpfil*78,
  341.      +          outfil*78,period*2,grafch*1,tabchr*2,typpar*14,ordinl*8,
  342.      +          errmsg*50,lintyp*16,linent*30,txtpar*49,messge*80
  343.       DIMENSION numpar(14),itypar(14,8),boulow(14,8),bouhig(14,8),
  344.      +          itxtpr(14,8),typpar(2),errmsg(9),lintyp(14),linent(14),
  345.      +          ordinl(8),txtpar(40),messge(3),entry(8),youngm(20)
  346.       common /coordi/ coonod(2,401)
  347.       common /sizebw/ malhbw
  348.       common /filenm/ inpfil,outfil
  349. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  350. C                                                                      C
  351. C                         ARRAY INITIALIZATION                         C
  352. C                                                                      C
  353. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  354.       DATA numpar /1,1,1,1,1,1,1,3,3,8,7,5,4,3/
  355.       DATA itypar /14*1,9*2,3*1,2,1,9*2,3*1,2,1,10*2,1,3*2,10*2,1,3*2,
  356.      +           10*1,4*2,10*2,4*1,14*2/
  357.       DATA boulow /1.,6*0.,7*1.,8*-10E18,0.,3*1.,-10E18,1.,8*-10E18,
  358.      +             0.,3*1.,2*-10E18,10*0.,1.,0.,2*-10E18,14*0.,10*1.,
  359.      +             4*0.,10*-10E18,4*1.,14*-10E18/
  360.       DATA bouhig /400.,20.,600.,500.,60.,100.,300.,7*0.,13*10E18,3.,
  361.      +             14*10E18,14*10E18,14*10E18,14*10E18,14*10E18,
  362.      +             14*10E18/
  363.       DATA typpar /' - an integer ',' - a number   '/
  364.       DATA errmsg /'UNEXPECTED END OF INPUT FILE.                     '
  365.      +            ,'INPUT LINE CONTAINS LESS DATA THAN REQUIRED.      '
  366.      +            ,'ENTRY CANNOT BE INTERPRETED AS A NUMBER.          '
  367.      +            ,'INCOMPATIBLE TYPE OF NUMERIC ENTRY IN INPUT LINE. '
  368.      +            ,'ENTRY IS OUTSIDE THE PROPER NUMERIC BOUNDS.       '
  369.      +            ,'THE STIFFNESS MATRIX BAND IS TOO WIDE.            '
  370.      +            ,'ELEMENT WITH TWO IDENTICAL NODES.                 '
  371.      +            ,'ELEMENT NODES SHARE THE SAME PHYSICAL LOCATION.   '
  372.      +            ,'DUPLICATED SPECIFICATIONS IN INPUT FILE.          '/
  373.       DATA lintyp /'model size      '
  374.      +            ,'model size      '
  375.      +            ,'model size      '
  376.      +            ,'model size      '
  377.      +            ,'model size      '
  378.      +            ,'model size      '
  379.      +            ,'model size      '
  380.      +            ,'node            '
  381.      +            ,'material        '
  382.      +            ,'beam            '
  383.      +            ,'plate           '
  384.      +            ,'fastener        '
  385.      +            ,'nodal loading   '
  386.      +            ,'nodal restraint '/
  387.       DATA linent /'                              '
  388.      +            ,'                              '
  389.      +            ,'                              '
  390.      +            ,'                              '
  391.      +            ,'                              '
  392.      +            ,'                              '
  393.      +            ,'                              '
  394.      +            ,'coordinates of node           '
  395.      +            ,'properties of material code   '
  396.      +            ,'properties of beam            '
  397.      +            ,'properties of plate           '
  398.      +            ,'properties of fastener        '
  399.      +            ,'applied loads to node         '
  400.      +            ,'imposed displacements to node '/
  401.       DATA ordinl /'first   '
  402.      +            ,'second  '
  403.      +            ,'third   '
  404.      +            ,'fourth  '
  405.      +            ,'fifth   '
  406.      +            ,'sixth   '
  407.      +            ,'seventh '
  408.      +            ,'eighth  '/
  409.       DATA itxtpr /1,2,3,4,5,6,7,8,11,14,22,29,34,38,
  410.      +             0,0,0,0,0,0,0,9,12,15,23,30,35,39,
  411.      +             0,0,0,0,0,0,0,10,13,16,24,31,36,40,
  412.      +             0,0,0,0,0,0,0,0,0,17,25,32,37,0,
  413.      +             0,0,0,0,0,0,0,0,0,18,26,33,0,0,
  414.      +             0,0,0,0,0,0,0,0,0,19,27,0,0,0,
  415.      +             0,0,0,0,0,0,0,0,0,20,28,0,0,0,
  416.      +             0,0,0,0,0,0,0,0,0,21,0,0,0,0/
  417.       stcons='                         '
  418.       line='
  419.      +                   '
  420.       slash='/ '
  421.       call setstr(2,slash)
  422.       space='  '
  423.       call setstr(2,space)
  424.       grafch=char(9)
  425.       tabchr='  '
  426.       call setstr(2,tabchr)
  427.       call movstr(tabchr,1,0,grafch,1,1)
  428.       chrerr=0
  429.       idparm=1
  430.       locatn=1
  431.       if (idline .eq. 1) linumb=0
  432.    10 linumb=linumb+1
  433.       ierror=1
  434.       READ (1,20,END=70,ERR=1000) buffer
  435.    20 FORMAT (A126)
  436.       call setstr(126,buffer)
  437.       ierror=0
  438.       ENDSEP=locstr(1,buffer,slash)
  439.       IF (ENDSEP .eq. 0) goto 10
  440.       call endstr (endsep+1,buffer)
  441.    25 itcons=locstr(locatn,buffer,tabchr)
  442.       if (itcons .ne. 0) then
  443.           call movstr (buffer,itcons,0,space,1,1)
  444.           locatn=itcons+1
  445.           goto 25
  446.       endif
  447.       locatn=1
  448.    30 IF (locatn .ge. ENDSEP) THEN
  449.           chrerr=ENDSEP
  450.           ierror=2
  451.           GOTO 70
  452.       endif
  453.       seprtr=locstr(locatn,buffer,space)
  454.       IF (seprtr .eq. locatn) THEN
  455.           locatn=locatn+1
  456.           GOTO 30
  457.       endif
  458.       IF ((seprtr .eq. 0) .OR. (seprtr .gt. ENDSEP)) seprtr=ENDSEP
  459.       ierror=0
  460.       decpop=0
  461.       EXPFLG=0
  462.       EXPSGN=0
  463.       seploc=seprtr-locatn
  464.       do 50 positn=1,SEPLOC
  465.       index=locatn+positn-1
  466.       asciic=ascstr(index,buffer)
  467.       IF ((asciic .gt. 47) .AND. (asciic .lt. 58)) goto 40
  468.       IF ((positn .eq. 1) .AND. ((asciic .eq. 43) .OR.
  469.      +   (asciic .eq. 45))) goto 40
  470.       IF ((asciic .eq. 46) .AND. (decpop .eq. 0)) THEN
  471.           decpop=locatn+positn-1
  472.           GOTO 40
  473.       endif
  474.       IF (((asciic .eq. 68) .OR. (asciic .eq. 69) .OR. (asciic .eq. 100)
  475.      +  .OR. (asciic .eq. 101)) .AND. (EXPFLG .eq. 0)) THEN
  476.           EXPFLG=locatn+positn
  477.           GOTO 40
  478.       endif
  479.       IF (((asciic .eq. 43) .OR. (asciic .eq. 45)) .AND. (EXPFLG .ne. 0)
  480.      +  .AND. (EXPSGN .eq. 0)) THEN
  481.           EXPSGN=locatn+positn
  482.           if (asciic .gt. 43) expsgn=-expsgn
  483.           GOTO 40
  484.       endif
  485.       ierror=3
  486.       chrerr=locatn+positn-1
  487.       goto 60
  488.    40 continue
  489.    50 continue
  490.    60 continue
  491.       IF (ierror .eq. 3) goto 70
  492.       call setstr(25,stcons)
  493.       call movstr(stcons,1,1,buffer,locatn,SEPLOC)
  494.       call resstr(stcons)
  495.       ftcons=fltstr(stcons)
  496.       IF ((ftcons .lt. boulow(idline,idparm)) .OR.
  497.      +  (ftcons .gt. bouhig(idline,idparm))) THEN
  498.           ierror=5
  499.           chrerr=locatn
  500.           GOTO 70
  501.       endif
  502.       IF ((itypar(idline,idparm) .eq. 1) .and.
  503.      +  (ftcons .ne. float(int(ftcons)))) then
  504.           ierror=4
  505.           IF (decpop .ne. 0) THEN
  506.               chrerr=decpop
  507.               GOTO 70
  508.           ELSE
  509.               IF (EXPSGN .lt. 0) THEN
  510.                   chrerr=-EXPSGN
  511.                   GOTO 70
  512.               ELSE
  513.                   chrerr=locatn
  514.                   GOTO 70
  515.               endif
  516.           endif
  517.       endif
  518.       entry(idparm)=ftcons
  519.       if ((idparm .eq. 1) .and. (idline .gt. 7) .and. (idline .lt. 14))
  520.      +    then
  521.           itcons=INT(ftcons)
  522.           CALL CHKDUP (itcons,ierror)
  523.           IF (ierror .ne. 0) THEN
  524.               ierror=9
  525.               chrerr=locatn
  526.               goto 70
  527.           endif
  528.       else
  529.           if ((idparm .eq. 2) .and. (idline .eq. 14)) then
  530.               itcons=INT(3*entry(1)+ftcons-3)
  531.               CALL CHKDUP (itcons,ierror)
  532.               IF (ierror .ne. 0) THEN
  533.                   ierror=9
  534.                   chrerr=locatn
  535.                   goto 70
  536.               endif
  537.           endif
  538.       endif
  539.       locatn=seprtr+1
  540.       idparm=idparm+1
  541.       IF (idparm .gt. numpar(idline)) THEN
  542.           if (idline .lt. 6) bouhig(idline+7,1)=entry(1)
  543.           if (idline .eq. 1) then
  544.               bouhig(10,2)=entry(1)
  545.               bouhig(10,3)=entry(1)
  546.               bouhig(11,2)=entry(1)
  547.               bouhig(11,3)=entry(1)
  548.               bouhig(11,4)=entry(1)
  549.               bouhig(11,5)=entry(1)
  550.               bouhig(12,2)=entry(1)
  551.               bouhig(12,3)=entry(1)
  552.               bouhig(13,1)=entry(1)
  553.               bouhig(14,1)=entry(1)
  554.           endif
  555.           if (idline .eq. 2) then
  556.               bouhig(10,6)=entry(1)
  557.               bouhig(11,7)=entry(1)
  558.           endif
  559.           if (((idline .eq. 10) .and. (entry(4) .ne. 0.) .and.
  560.      +         (youngm(int(entry(6))) .ne. 0.)) .or.
  561.      +        ((idline .eq. 12) .and. (entry(5) .ne. 0.))) then
  562.               nod1=int(entry(2))
  563.               nod2=int(entry(3))
  564.               lbanwd=3*(1+abs(nod1-nod2))
  565.               if (lbanwd .gt. malhbw) then
  566.                   ierror=6
  567.                   goto 70
  568.               else
  569.                   if (lbanwd .eq. 3) then
  570.                       ierror=7
  571.                       goto 70
  572.                   endif
  573.               endif
  574.               if (idline .eq. 10) then
  575.                   if ((coonod(1,nod1) .eq. coonod(1,nod2)) .and.
  576.      +                (coonod(2,nod1) .eq. coonod(2,nod2))) then
  577.                       ierror=8
  578.                       goto 70
  579.                   endif
  580.               endif
  581.               if (lbanwd .gt. maxban) maxban=lbanwd
  582.           else
  583.               if ((idline .eq. 11) .and. (entry(6) .ne. 0.) .and.
  584.      +            (youngm(int(entry(7))) .ne. 0.)) then
  585.                   maxnod=max(int(entry(2)),int(entry(3)),
  586.      +                        int(entry(4)))
  587.                   minnod=min(int(entry(2)),int(entry(3)),
  588.      +                        int(entry(4)))
  589.                   if (entry(5) .ne. 0.) then
  590.                       maxnod=max(maxnod,int(entry(5)))
  591.                       minnod=min(minnod,int(entry(5)))
  592.                   endif
  593.                   lbanwd=3*(1+maxnod-minnod)
  594.                   if (lbanwd .gt. malhbw) then
  595.                       ierror=6
  596.                       goto 70
  597.                   endif
  598.                   do 65 itcons=2,4
  599.                   nod1=int(entry(itcons))
  600.                   startp=itcons+1
  601.                   do 65 index=startp,5
  602.                   nod2=int(entry(index))
  603.                   if (nod2 .ne. 0) then
  604.                       if (nod1 .eq. nod2) then
  605.                           ierror=7
  606.                           goto 70
  607.                       else
  608.                           if ((coonod(1,nod1) .eq. coonod(1,nod2)) .and.
  609.      +                        (coonod(2,nod1) .eq. coonod(2,nod2))) then
  610.                               ierror=8
  611.                               goto 70
  612.                           endif
  613.                       endif
  614.                   endif
  615.    65             continue
  616.                   if (lbanwd .gt. maxban) maxban=lbanwd
  617.               endif
  618.           endif
  619.           goto 3000
  620.       ELSE
  621.           goto 30
  622.       endif
  623.    70 txtpar(1)='number of nodes in the model                     '
  624.       txtpar(2)='number of types of materials in the model        '
  625.       txtpar(3)='number of beams in the model                     '
  626.       txtpar(4)='number of plates in the model                    '
  627.       txtpar(5)='number of fasteners in the model                 '
  628.       txtpar(6)='number of loaded nodes in the model              '
  629.       txtpar(7)='number of restrained displacements in the model  '
  630.       txtpar(8)='node number                                      '
  631.       txtpar(9)='x coordinate of the node                         '
  632.       txtpar(10)='y coordinate of the node                         '
  633.       txtpar(11)='material number                                  '
  634.       txtpar(12)='Young''s modulus of the material                 '
  635.       txtpar(13)='Poisson''s ratio of the material                 '
  636.       txtpar(14)='beam number                                      '
  637.       txtpar(15)='index of the first node of the beam              '
  638.       txtpar(16)='index of the second node of the beam             '
  639.       txtpar(17)='beam area                                        '
  640.       txtpar(18)='beam moment of inertia                           '
  641.       txtpar(19)='beam material code                               '
  642.       txtpar(20)='distributed load at the first node of the beam   '
  643.       txtpar(21)='distributed load at the second node of the beam  '
  644.       txtpar(22)='plate number                                     '
  645.       txtpar(23)='index of the first node of the plate             '
  646.       txtpar(24)='index of the second node of the plate            '
  647.       txtpar(25)='index of the third node of the plate             '
  648.       txtpar(26)='index of the fourth node of the plate            '
  649.       txtpar(27)='plate thickness                                  '
  650.       txtpar(28)='plate material code                              '
  651.       txtpar(29)='fastener number                                  '
  652.       txtpar(30)='index of the first node of the fastener          '
  653.       txtpar(31)='index of the second node of the fastener         '
  654.       txtpar(32)='fastener area                                    '
  655.       txtpar(33)='fastener stiffness                               '
  656.       txtpar(34)='loaded node number                               '
  657.       txtpar(35)='applied load at the node along the x direction   '
  658.       txtpar(36)='applied load at the node along the y direction   '
  659.       txtpar(37)='applied moment at the node along the z direction '
  660.       txtpar(38)='node number with a restrained degree of freedom  '
  661.       txtpar(39)='restrained degree of freedom of the node         '
  662.       txtpar(40)='imposed displacement at the node                 '
  663.       write (*,80) errmsg(ierror)
  664.    80 FORMAT (//' ERROR : ',A50)
  665.       call diskroom (67)
  666.       write (2,80,err=2000) errmsg(ierror)
  667.       messge(1)='
  668.      +                         '
  669.       messge(2)='
  670.      +                         '
  671.       messge(3)='
  672.      +                         '
  673.       call setstr (240,MESSGE(1))
  674.       stcons='Encountered              '
  675.       call movstr (messge(1),1,1,stcons,1,11)
  676.       IF (ierror .eq. 1) THEN
  677.           stcons=' attempting to read      '
  678.       ELSE
  679.           stcons=' in                      '
  680.       endif
  681.       call setstr (25,stcons)
  682.       call constr (messge(1),stcons)
  683.       call pakstr (messge(1))
  684.       stcons=' line                    '
  685.       call setstr (6,stcons)
  686.       call constr (messge(1),stcons)
  687.       call pakstr (messge(1))
  688.       call constr (messge(1),space)
  689.       call wrfstr (float(linumb),stcons)
  690.       call constr (messge(1),stcons)
  691.       call pakstr (messge(1))
  692.       stcons=' of file                 '
  693.       call setstr (9,stcons)
  694.       call constr (messge(1),stcons)
  695.       call constr (messge(1),space)
  696.       call setstr (78,inpfil)
  697.       call pakstr (inpfil)
  698.       call constr (messge(1),inpfil)
  699.       period='. '
  700.       call setstr (2,period)
  701.       call constr (messge(1),period)
  702.       call writxt (messge)
  703.       IF (ierror .eq. 1) goto 3000
  704.       grafch=char(218)
  705.       call setstr (79,line)
  706.       call filstr (196,line)
  707.       call movstr (line,1,0,grafch,1,1)
  708.       if (chrerr .ne. 0) then
  709.           grafch=char(25)
  710.           call movstr (line,chrerr+1,0,grafch,1,1)
  711.       endif
  712.       length=lenstr (buffer)+2
  713.       grafch=char(191)
  714.       call movstr (line,length,0,grafch,1,1)
  715.       length=length+1
  716.       call endstr (length,line)
  717.       call resstr (line)
  718.       write (*,90) line
  719.    90 format (1x,A79)
  720.       call diskroom (82)
  721.       write (2,90,err=2000) line
  722.       length=length-3
  723.       call setstr (79,line)
  724.       grafch=char(179)
  725.       call movstr (line,1,0,grafch,1,1)
  726.       call movstr (line,2,0,buffer,1,length)
  727.       length=length+2
  728.       call movstr (line,length,0,grafch,1,1)
  729.       length=length+1
  730.       call endstr (length,line)
  731.       call resstr (line)
  732.       write (*,90) line
  733.       call diskroom (82)
  734.       write (2,90,err=2000) line
  735.       grafch=char(192)
  736.       call setstr (79,line)
  737.       call filstr (196,line)
  738.       call movstr (line,1,0,grafch,1,1)
  739.       if (chrerr .ne. 0) then
  740.           grafch=char(24)
  741.           call movstr (line,chrerr+1,0,grafch,1,1)
  742.       endif
  743.       length=lenstr (buffer)+2
  744.       grafch=char(217)
  745.       call movstr (line,length,0,grafch,1,1)
  746.       length=length+1
  747.       call endstr (length,line)
  748.       call resstr (line)
  749.       write (*,90) line
  750.       call diskroom (82)
  751.       write (2,90,err=2000) line
  752.       call filstr (32,messge(1))
  753.       if (ierror .eq. 6) then
  754.           stcons=' The bandwidth for       '
  755.           call movstr (messge(1),1,0,stcons,1,18)
  756.           call movstr (messge(1),20,0,lintyp(idline),1,16)
  757.           call pakstr (messge(1))
  758.           call constr (messge(1),space)
  759.           call wrfstr (entry(1),stcons)
  760.           call constr (messge(1),stcons)
  761.           stcons=' is                      '
  762.           call setstr (4,stcons)
  763.           call constr (messge(1),stcons)
  764.           call constr (messge(1),space)
  765.           call wrfstr (float(lbanwd),stcons)
  766.           call constr (messge(1),stcons)
  767.           stcons=' and exceeds the maximum '
  768.           call setstr (25,stcons)
  769.           call constr (messge(1),stcons)
  770.           stcons=' allowed bandwidth of    '
  771.           call setstr (22,stcons)
  772.           call constr (messge(1),stcons)
  773.           call constr (messge(1),space)
  774.           call wrfstr (float(malhbw),stcons)
  775.           call constr (messge(1),stcons)
  776.           call constr (messge(1),period)
  777.           call writxt (messge)
  778.           goto 3000
  779.       endif
  780.       if (ierror .eq. 7) then
  781.           stcons=' There are identical node'
  782.           call movstr (messge(1),1,0,stcons,1,25)
  783.           call pakstr (messge(1))
  784.           stcons='s in                     '
  785.           call setstr (5,stcons)
  786.           call constr (messge(1),stcons)
  787.           call constr (messge(1),space)
  788.           call setstr (16,lintyp(idline))
  789.           call constr (messge(1),lintyp(idline))
  790.           call resstr (lintyp(idline))
  791.           call pakstr (messge(1))
  792.           call constr (messge(1),space)
  793.           call wrfstr (entry(1),stcons)
  794.           call constr (messge(1),stcons)
  795.           call constr (messge(1),period)
  796.           call writxt (messge)
  797.           goto 3000
  798.       endif
  799.       if (ierror .eq. 8) then
  800.           stcons=' Nodes                   '
  801.           call movstr (messge(1),1,0,stcons,1,6)
  802.           call pakstr (messge(1))
  803.           call constr (messge(1),space)
  804.           call wrfstr (float(nod1),stcons)
  805.           call constr (messge(1),stcons)
  806.           stcons=' and                     '
  807.           call setstr (5,stcons)
  808.           call constr (messge(1),stcons)
  809.           call constr (messge(1),space)
  810.           call wrfstr (float(nod2),stcons)
  811.           call constr (messge(1),stcons)
  812.           stcons=' of                      '
  813.           call setstr (5,stcons)
  814.           call constr (messge(1),stcons)
  815.           call setstr (16,lintyp(idline))
  816.           call constr (messge(1),lintyp(idline))
  817.           call resstr (lintyp(idline))
  818.           call pakstr (messge(1))
  819.           call constr (messge(1),space)
  820.           call wrfstr (entry(1),stcons)
  821.           call constr (messge(1),stcons)
  822.           stcons=' have the same coordinat '
  823.           call setstr (25,stcons)
  824.           call constr (messge(1),stcons)
  825.           stcons='es.                      '
  826.           call setstr (4,stcons)
  827.           call constr (messge(1),stcons)
  828.           call writxt (messge)
  829.           goto 3000
  830.       endif
  831.       if (ierror .eq. 9) then
  832.           stcons=' The                     '
  833.           call movstr (messge(1),1,0,stcons,1,5)
  834.           call pakstr (messge(1))
  835.           call constr (messge(1),space)
  836.           call setstr (30,linent(idline))
  837.           call constr (messge(1),linent(idline))
  838.           call resstr (linent(idline))
  839.           call pakstr (messge(1))
  840.           call constr (messge(1),space)
  841.           call wrfstr (entry(1),stcons)
  842.           call constr (messge(1),stcons)
  843.           stcons=' appear twice.           '
  844.           call setstr (15,stcons)
  845.           call constr (messge(1),stcons)
  846.           call writxt (messge)
  847.           goto 3000
  848.       endif
  849.       stcons=' Reading                 '
  850.       call movstr (messge(1),1,0,stcons,1,8)
  851.       if (idparm .eq. 1) then
  852.           call movstr (messge(1),10,0,lintyp(idline),1,16)
  853.           call pakstr (messge(1))
  854.           stcons=' lines                   '
  855.           call setstr (7,stcons)
  856.           call constr (messge(1),stcons)
  857.       else
  858.           call movstr (messge(1),10,0,linent(idline),1,30)
  859.           call pakstr (messge(1))
  860.           call constr (messge(1),space)
  861.           call wrfstr (entry(1),stcons)
  862.           call constr (messge(1),stcons)
  863.       endif
  864.       stcons=' it was expected to find '
  865.       call setstr(25,stcons)
  866.       call constr(messge(1),stcons)
  867.       if ((idparm .eq. 1) .and. (idline .gt. 7)) then
  868.           stcons=' a                       '
  869.       else
  870.           stcons=' the                     '
  871.       endif
  872.       call setstr (5,stcons)
  873.       call constr (messge(1),stcons)
  874.       call pakstr (messge(1))
  875.       call constr (messge(1),space)
  876.       index=itxtpr(idline,idparm)
  877.       call setstr (49,txtpar(index))
  878.       call constr (messge(1),txtpar(index))
  879.       call resstr (txtpar(index))
  880.       call pakstr (messge(1))
  881.       index=itypar(idline,idparm)
  882.       call setstr (14,typpar(index))
  883.       call constr (messge(1),typpar(index))
  884.       call resstr (typpar(index))
  885.       call pakstr (messge(1))
  886.       stcons=' between                 '
  887.       call setstr (10,stcons)
  888.       call constr (messge(1),stcons)
  889.       call wrfstr (boulow(idline,idparm),stcons)
  890.       call constr (messge(1),stcons)
  891.       stcons=' and                     '
  892.       call setstr (6,stcons)
  893.       call constr (messge(1),stcons)
  894.       call wrfstr (bouhig(idline,idparm),stcons)
  895.       call constr (messge(1),stcons)
  896.       stcons=' - as the                '
  897.       call setstr (11,stcons)
  898.       call constr (messge(1),stcons)
  899.       call setstr (8,ordinl(idparm))
  900.       call constr (messge(1),ordinl(idparm))
  901.       call resstr (ordinl(idparm))
  902.       call pakstr (messge(1))
  903.       stcons=' entry.                  '
  904.       call setstr (8,stcons)
  905.       call constr (messge(1),stcons)
  906.       call writxt (messge)
  907.       goto 3000
  908.  1000 write (*,1010)
  909.  1010 format (//' ERROR : CANNOT READ INPUT FILE.'/
  910.      +          ' The program cannot continue.')
  911.       ierror=-1
  912.       goto 3000
  913.  2000 write (*,2010)
  914.  2010 format (//' ERROR : CANNOT WRITE OUTPUT FILE.'/
  915.      +          ' The program cannot continue.')
  916.       ierror=-1
  917.  3000 return
  918.       end
  919. $PAGE
  920.       SUBROUTINE writxt (messge)
  921. C
  922. C  Write text on the screen formatting to avoid breaking words
  923. C
  924.       IMPLICIT INTEGER (a-z)
  925.       CHARACTER messge*80,line*79,endwrd*3,space*2
  926.       DIMENSION messge(3)
  927.       line='
  928.      +                   '
  929.       call setstr (79,line)
  930.       endwrd='   '
  931.       call setstr (3,endwrd)
  932.       space='  '
  933.       call setstr (2,space)
  934.       call expstr (messge(1))
  935.       startp=1
  936.       endtxt=locstr (1,messge(1),endwrd)
  937.   110 index=startp+79
  938.       IF (ENDTXT .ge. index) THEN
  939.           spcpos=startp-1
  940.   120     nxtspc=spcpos+1
  941.           length=locstr (nxtspc,messge(1),space)
  942.           IF (length .lt. index) THEN
  943.               spcpos=length
  944.               GOTO 120
  945.           endif
  946.           length=spcpos-startp
  947.           call movstr (line,1,1,messge(1),startp,length)
  948.           call resstr (line)
  949.           write (*,90) line
  950.    90     format (1x,A79)
  951.           call diskroom (82)
  952.           write (2,90,err=2000) line
  953.           call setstr (79,line)
  954.           startp=spcpos+1
  955.           GOTO 110
  956.       endif
  957.       endtxt=endtxt-1
  958.       call movstr (line,1,1,messge(1),startp,ENDTXT)
  959.       call resstr (line)
  960.       write (*,90) line
  961.       call diskroom (82)
  962.       write (2,90,err=2000) line
  963.       goto 3000
  964.  2000 write (*,2010)
  965.  2010 format (//' ERROR : CANNOT WRITE OUTPUT FILE.'/
  966.      +          ' The program cannot continue.')
  967.       ierror=-1
  968.  3000 return
  969.       end
  970. $PAGE
  971.       FUNCTION degree (oppsid,closid)
  972. C
  973. C  Determine angle in degrees with opposite and next side of triangle.
  974. C
  975.       IF (abs(closid) .gt. 1e-19) THEN
  976.           degree=57.2957795*ATAN(oppsid/closid)
  977.           IF (closid .LT. 0.) degree=degree+180.
  978.           IF (degree .gt. 180.) degree=degree-360.
  979.       ELSE
  980.           IF (oppsid .ge. 0.) then
  981.               degree=90.
  982.           else
  983.               degree=-90.
  984.           endif
  985.       ENDIF
  986.       RETURN
  987.       END
  988. $PAGE
  989.       SUBROUTINE datstr(string)
  990. C
  991. C  Write the date in a string.
  992. C
  993.       IMPLICIT integer (a-z)
  994.       CHARACTER string*11,blank*2,buffer*10
  995.       call date (day,month,year)
  996.       write (buffer,10) month,day,year
  997.    10 FORMAT (i2,'/',i2,'/',i4)
  998.       READ (buffer,20) string
  999.    20 format (a10)
  1000.       call setstr (11,string)
  1001.       asciic=ascstr(4,string)
  1002.       if (asciic .eq. 32) call modstr (string,4,48)
  1003.       RETURN
  1004.       END
  1005. $PAGE
  1006.       SUBROUTINE timstr(string)
  1007. C
  1008. C  Write the time-of-day in a string.
  1009. C
  1010.       IMPLICIT integer (a-z)
  1011.       real realsc
  1012.       CHARACTER string*12,blank*2,buffer*11
  1013.       call time (hour,minute,second,sec100)
  1014.       realsc=float(second)+float(sec100)/100.
  1015.       write (buffer,10) hour,minute,realsc
  1016.    10 FORMAT (i2,':',i2,':',f5.2)
  1017.       READ (buffer,20) string
  1018.    20 format (a11)
  1019.       call setstr (12,string)
  1020.       asciic=ascstr(4,string)
  1021.       if (asciic .eq. 32) call modstr (string,4,48)
  1022.       asciic=ascstr(7,string)
  1023.       if (asciic .eq. 32) then
  1024.           call modstr (string,7,48)
  1025.           asciic=ascstr(8,string)
  1026.           if (asciic .eq. 32) call modstr (string,8,48)
  1027.       endif
  1028.       RETURN
  1029.       END
  1030. $PAGE
  1031.       FUNCTION fltstr (string)
  1032. C
  1033. C  Calculate the floating point value of a string.
  1034. C
  1035.       CHARACTER buffer*26,string*25
  1036.       write (buffer,*) string
  1037.       READ (buffer,10,ERR=300) intstr
  1038.    10 format (bn,i25)
  1039.       fltstr=float(intstr)
  1040.       goto 500
  1041.   300 fltstr=0
  1042.       READ (buffer,310,ERR=500) fltstr
  1043.   310 format (bn,f25.0)
  1044.   500 RETURN
  1045.       END
  1046. $PAGE
  1047.       SUBROUTINE wrfstr (real,string)
  1048. C
  1049. C  Write a real in a string.
  1050. C
  1051.       implicit integer (a-z)
  1052.       real real
  1053.       CHARACTER string*25,expnnt*5
  1054.       if (real .eq. 0.) then
  1055.           string='0                        '
  1056.           call setstr (25,string)
  1057.           call endstr (2,string)
  1058.       else
  1059.           if ((abs(real) .ge. 1.e11) .or. (abs(real) .lt. 1.e-5)) then
  1060.               write (string,10) real
  1061.    10         format (E12.6E2)
  1062.               call setstr (25,string)
  1063.               call pakstr (string)
  1064.               expnnt='E    '
  1065.               call setstr (5,expnnt)
  1066.               call endstr (2,expnnt)
  1067.               l=locstr (1,string,expnnt)
  1068.               call movstr (expnnt,1,1,string,l,4)
  1069.    30         l=l-1
  1070.               if (ascstr(l,string) .eq. 48) goto 30
  1071.               call movstr (string,l+1,1,expnnt,1,4)
  1072.           else
  1073.               write (string,40) real
  1074.    40         format (F19.10)
  1075.               call setstr (25,string)
  1076.               call pakstr (string)
  1077.               l=lenstr (string)+1
  1078.    50         l=l-1
  1079.               if (ascstr(l,string) .eq. 48) goto 50
  1080.               if (ascstr(l,string) .eq. 46) l=l-1
  1081.               call endstr (l+1,string)
  1082.           endif
  1083.       endif
  1084.       RETURN
  1085.       END
  1086.